home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 …SCII & the Runetime Code / ADC Developer CD (1992-07) (''Butch ASCII And The Runtime Code'')_iso / Dev.CD 199207.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / DNET / DNET-Browser.lisp < prev    next >
Encoding:
Text File  |  1990-06-24  |  19.2 KB  |  438 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         DNET-BROWSER.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      25-May-88 22:54:37
  17. ; Modified:     22-Jun-90 02:34:16 (Dan Suthers)
  18. ; Language:     LISP
  19. ; Package:      DNET
  20. ;
  21. ; Description:  Browser of the contents of a DNET.
  22. ;
  23. ; (c) Copyright 1988, by Daniel D. Suthers
  24. ;                        Department of Computer and Information Science
  25. ;                        University of Massachusetts
  26. ;                        Amherst, Massachusetts 01003
  27. ;
  28. ; This software was conceived, designed, and written by Dan Suthers 
  29. ; while supported by the National Science Foundation under grant number
  30. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  31. ; CA.  Partial support was also received from the Office of Naval Research
  32. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  33. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  34. ; the above grants and encouraged me to pursue my own research interests in
  35. ; her lab.  This work would not have been possible without the resources and
  36. ; stimulating environment of the Computer and Information Science department.
  37. ;
  38. ; Permission to use, modify, and distribute this software is granted subject 
  39. ; to the following restrictions and understandings:
  40. ; 1. The file header, including this notice, shall be retained, and may be
  41. ;    extended to include documentation of modifications to the software.
  42. ; 2. This material is for nonprofit educational and research purposes only.
  43. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  44. ;    noteworthy uses of this software.
  45. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  46. ;    representation that the operation of this software will be error free,
  47. ;    and are under no obligation to provide any services.
  48. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  49. ;    Suthers and the University of Massachusetts from all claims arising 
  50. ;    out of the use or misuse of this software, or arising out of any 
  51. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  52. ;    fees, and liabilities incurred in or about any such claim, action, or
  53. ;    proceeding brought thereon.
  54. ; 5. All materials and reports developed as a consequence of the use of 
  55. ;    this software shall duly acknowledge such use, in accordance with
  56. ;    the usual standards of acknowledging credit in academic research.
  57. ;
  58. ; Status:       Works, but this is a primitive interface.  I recommend 
  59. ;               loading DNETs from other easier to edit data structures.
  60. ;
  61. ; Tested:       Macintosh II Coral/Allegro 19-Jul-88 16:22:16
  62. ;
  63. ; Changes:
  64. ;
  65. ;  08-Jun-88 Choice of build or browse default actions in browse-dnet.
  66. ;  19-Jul-88 Save Dnet menu gives default path.
  67. ;  23-Jul-88 No longer display bindings, for efficiency and readability.
  68. ;   They are usually obvious.  Instead, info & bindings buttons give you
  69. ;   this further information on the most recently retrieved expressions.
  70. ;  25-Jan-90 Fixed bug in asking dead menu to install itself.
  71. ;  30-Jan-90 Updated for version 1.3.1: :default-button now in buttons.
  72. ;
  73. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74.  
  75. (in-package :DNET)
  76.  
  77. (export '(
  78.           browse-dnets
  79.           ))
  80.  
  81. (require :DIALOGUE)
  82. (require :SM      )
  83. (require :SMEDIT  )
  84. (require :DNET    )
  85.  
  86. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87. ;;; For convenience of the user
  88.  
  89. (defvariable x)
  90. (defvariable y)
  91. (defvariable z)
  92.  
  93. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94.  
  95. (defconstant *help-string* 
  96.   "To Use:
  97.   1. Select a discrimination net from the menu. (You may make new nets via
  98.      the Structure Manager Browser.)
  99.   2. Enter retrieval expression or pattern above (in smaller text window).
  100.   3. Select the desired action button:
  101.      - Retrieve Pattern retrieves and prints all expressions in the DNET
  102.        matching the pattern you typed in (variables used).
  103.      - Retrieve Expression retrieves and prints all expressions OR patterns
  104.        in the DNET matching your expression (variables not used).
  105.      - Add and Delete perform the indicated operation on the expression
  106.        you gave.
  107.      - Show Info and Bindings show the corresponding information for 
  108.        the last set of retrieved expressions.")
  109.  
  110. (defun BROWSE-DNETS (&optional (build-mode nil))
  111.   "browse-dnets &optional <build-mode>                              [Function]
  112.   Puts up a discrimination net browser.  If <build-mode> is nil (default), 
  113.   the default button is for pattern retrieval; if T, the default is for
  114.   adding an expression."
  115.   (macrolet ((with-selected-dnet (body)
  116.                ;; Binds dnet to the dnet selected and executes body, unless error.
  117.                `(let ((dnet
  118.                        (ccl:ask dnet-menu
  119.                                 (if (ccl:selected-cells)
  120.                                   (ccl:cell-contents (car (ccl:selected-cells)))))))
  121.                   (if (null dnet)
  122.                     (ccl:ask display-window 
  123.                              (ccl:set-dialog-item-text
  124.                               (concatenate 'string "You must select a DNET first.
  125. "
  126.                                            *help-string*)))
  127.                     ,body)))
  128.              (with-selected-expression (body)
  129.                ;; Binds expression to the retrieved expression, and dnet to the
  130.                ;; dnet it is in, and executes body; unless an error is encountered
  131.                ;; in the process.
  132.                `(let ((expression-string
  133.                        (ccl:ask entry-window (ccl:dialog-item-text)))
  134.                       (expression nil)
  135.                       (dnet
  136.                        (ccl:ask dnet-menu
  137.                                 (if (ccl:selected-cells)
  138.                                   (ccl:cell-contents (car (ccl:selected-cells)))))))
  139.                   (cond 
  140.                    ((null dnet)
  141.                     (ccl:ask display-window 
  142.                              (ccl:set-dialog-item-text
  143.                               (concatenate 'string "You must select a DNET first.
  144. "
  145.                                            *help-string*))))
  146.                    ((and expression-string dnet)
  147.                     (setf expression (read-from-string expression-string nil '$eof$))
  148.                     (if (eq expression '$eof$)
  149.                       (ccl:ask display-window 
  150.                                (ccl:set-dialog-item-text
  151.                                 "Error on read of your expression."))
  152.                       ,body))))))
  153.     (let*
  154.       (
  155.        ;; These are used to communicate between buttons.
  156.        (retrieved-expressions nil)
  157.        (retrieved-bindings    nil)
  158.        
  159.        ;;----------------
  160.        ;; Display Windows
  161.        
  162.        ;; Window in which user types retrieval patterns.
  163.        (entry-window
  164.         (ccl:oneof ccl:*editable-text-dialog-item*
  165.                    :dialog-item-size (ccl:make-point 575 50)
  166.                    :dialog-item-position (ccl:make-point 8 80)
  167.                    :dialog-item-font '("monaco" 12)
  168.                    :dialog-item-text ""
  169.                    :allow-returns nil))
  170.        
  171.        ;; Window where the retrieved patterns are displayed.
  172.        (display-window
  173.         (ccl:oneof ccl:*editable-text-dialog-item*
  174.                    :dialog-item-size (ccl:make-point 575 
  175.                                                      (if build-mode 130 230))
  176.                    :dialog-item-position (ccl:make-point 8 145)
  177.                    :dialog-item-font '("monaco" 12)
  178.                    :dialog-item-text *help-string*
  179.                    :allow-returns t))
  180.        
  181.        ;;-----------------------------     
  182.        ;; Menu for selecting the DNET.
  183.        (dnet-menu 
  184.         (ccl:oneof ccl:*sequence-dialog-item*
  185.                    :dialog-item-size (ccl:make-point 150 84)
  186.                    :dialog-item-position (ccl:make-point 420 15)
  187.                    :table-vscrollp t
  188.                    :table-hscrollp nil
  189.                    :visible-dimensions (ccl:make-point 1 3)
  190.                    :cell-size (ccl:make-point 140 16)
  191.                    :table-sequence 
  192.                    (sm:instances 'dnet)
  193.                    :sequence-order :vertical))
  194.        
  195.        ;;-----------------------------------------
  196.        ;; Buttons left to right across the top ...
  197.        
  198.        ;; Retrieve based on the current pattern.
  199.        (retrieve-pattern
  200.         (ccl:oneof
  201.          ccl:*button-dialog-item*
  202.          :dialog-item-text "Retrieve Pattern"
  203.          :dialog-item-position (ccl:make-point 10 15)
  204.          :dialog-item-enabled-p t
  205.          :dialog-item-action
  206.          #'(lambda ()
  207.              (with-selected-expression
  208.                (ccl:ask 
  209.                 display-window 
  210.                 (multiple-value-setq 
  211.                  (retrieved-expressions retrieved-bindings)
  212.                  (match-pattern expression dnet))
  213.                 (ccl:set-dialog-item-text
  214.                  (let ((*print-pretty* t))
  215.                    (format nil "~{~S~%~}" retrieved-expressions))))))
  216.          :default-button (not build-mode)))
  217.        
  218.        ;; Retrieve based on the current expression (not pattern).
  219.        (retrieve-expression
  220.         (ccl:oneof
  221.          ccl:*button-dialog-item*
  222.          :dialog-item-text "Retrieve Expression"
  223.          :dialog-item-position (ccl:make-point 10 47)
  224.          :dialog-item-enabled-p t
  225.          :dialog-item-action
  226.          #'(lambda ()
  227.              (with-selected-expression
  228.                (ccl:ask 
  229.                 display-window 
  230.                 (multiple-value-setq 
  231.                  (retrieved-expressions retrieved-bindings)
  232.                  (match-expression expression dnet))
  233.                 (ccl:set-dialog-item-text
  234.                  (let ((*print-pretty* t))
  235.                    (format nil "~{~S~%~}" retrieved-expressions))))))))
  236.  
  237.        ;; Add an expression
  238.        (add-expression
  239.         (ccl:oneof
  240.          ccl:*button-dialog-item*
  241.          :dialog-item-text "Add Expression"
  242.          :dialog-item-position (ccl:make-point 166 15)
  243.          :dialog-item-enabled-p t
  244.          :dialog-item-action
  245.          #'(lambda ()
  246.              (with-selected-expression
  247.                (multiple-value-bind
  248.                  (added-p terminal)
  249.                  (indexpr expression dnet)
  250.                  (declare (ignore terminal))
  251.                  (if added-p
  252.                    (ccl:ask display-window 
  253.                             (ccl:set-dialog-item-text 
  254.                              (format nil "~%~S added to ~S" expression dnet)))
  255.                    (ccl:ask display-window 
  256.                             (ccl:set-dialog-item-text 
  257.                              (format nil "~%~S Already Present in ~S" 
  258.                                      expression dnet)))))))
  259.          :default-button build-mode))
  260.        
  261.        ;; Delete expression.
  262.        (delete-selected
  263.         (ccl:oneof 
  264.          ccl:*button-dialog-item*
  265.          :dialog-item-text "Delete Expression"
  266.          :dialog-item-position (ccl:make-point 166 47)
  267.          :dialog-item-enabled-p t
  268.          :dialog-item-action
  269.          #'(lambda ()
  270.              (with-selected-expression
  271.                (if (delexpr expression dnet)
  272.                  (ccl:ask display-window 
  273.                           (ccl:set-dialog-item-text
  274.                            (format nil "~%~S Deleted from ~S" 
  275.                                    expression dnet)))
  276.                  (ccl:ask display-window 
  277.                           (ccl:set-dialog-item-text 
  278.                            (format nil "~%~S was not found in ~S" 
  279.                                    expression dnet))))))))
  280.        
  281.        ;; Property list manipulation.
  282.        (show-expr-info
  283.         (ccl:oneof
  284.          ccl:*button-dialog-item*
  285.          :dialog-item-text "Show Info"
  286.          :dialog-item-position (ccl:make-point 305 15)
  287.          :dialog-item-enabled-p t
  288.          :dialog-item-action
  289.          #'(lambda ()
  290.              (with-selected-dnet
  291.                (ccl:ask display-window 
  292.                         (ccl:set-dialog-item-text
  293.                          (format nil "~{~S~%  Info: ~S~%~%~}" 
  294.                                  (mapcan #'(lambda (e) (list e (expr-info e dnet)))
  295.                                          retrieved-expressions))))))))
  296.  
  297.        ;; Editing info done by EDITS (Fred window).  Only the INFO is displayed,
  298.        ;; as the EXPR cannot be edited without reindexing.
  299.        (show-bindings
  300.         (ccl:oneof 
  301.          ccl:*button-dialog-item*
  302.          :dialog-item-text "Show Bindings"
  303.          :dialog-item-position (ccl:make-point 305 47)
  304.          :dialog-item-enabled-p t
  305.          :dialog-item-action
  306.          #'(lambda ()
  307.              (ccl:ask
  308.               display-window 
  309.               (ccl:set-dialog-item-text
  310.                (format nil "~{~S~%  Bindings: ~S~%~%~}" 
  311.                        (do ((eptr retrieved-expressions (cdr eptr))
  312.                             (bptr retrieved-bindings (cdr bptr))
  313.                             (result (list :head)))
  314.                            ((null eptr) (cdr result))
  315.                          (nconc result (list (first eptr) (first bptr))))))))))
  316.  
  317.        ;; Create the browser window itself.
  318.        (browser 
  319.         (ccl:oneof ccl:*dialog*
  320.                    :window-title (if build-mode 
  321.                                    " Discrimination Net Builder "
  322.                                    " Discrimination Net Browser ")
  323.                    :window-position (ccl:make-point 25 45)
  324.                    :window-size (ccl:make-point 592 (if build-mode 285 385))
  325.                    :window-type :tool
  326.                    :dialog-items (list retrieve-expression retrieve-pattern 
  327.                                        add-expression delete-selected
  328.                                        show-expr-info show-bindings
  329.                                        dnet-menu
  330.                                        entry-window
  331.                                        display-window))))
  332.       browser)))
  333.  
  334. (defparameter *DNET-MENU*
  335.   (let* ((line-item
  336.           (ccl:oneof ccl:*menu-item*
  337.                      :menu-item-title "-"))
  338.          (browse-item 
  339.           (ccl:oneof ccl:*menu-item*
  340.                      :menu-item-title "DNET Browser ..."
  341.                      :menu-item-action 
  342.                      #'(lambda () 
  343.                          (browse-dnets
  344.                           (not 
  345.                            (wind:y-or-n-dialogue
  346.                             "Is your primary activity Browsing (as opposed to building)?"))))))
  347.          (destroy-dnet-item
  348.           (ccl:oneof ccl:*menu-item*
  349.                      :menu-item-title "Destroy DNET ..."
  350.                      :menu-item-action
  351.                      #'(lambda ()
  352.                          (let ((dnet
  353.                                 (wind:menu-dialogue
  354.                                  (sm:instances 'dnet)
  355.                                  "Destroy which DNET?")))
  356.                            (destroy-dnet dnet)))))
  357.          (save-dnet-item
  358.           (ccl:oneof 
  359.            ccl:*menu-item*
  360.            :menu-item-title "Save DNET ..."
  361.            :menu-item-action 
  362.            #'(lambda ()
  363.                (let* ((dnet
  364.                        (wind:menu-dialogue
  365.                         (sm:instances 'dnet)
  366.                         "Save to disk which DNET?"))
  367.                       (file-path
  368.                        (pathname 
  369.                         (ccl:choose-new-file-dialog
  370.                          :prompt 
  371.                          (format nil "Save ~A to ..." dnet)
  372.                          :directory
  373.                          ;; Use same path but corrected name.
  374.                          (let ((prev-path (or (get 'dnet 'sm::$SM-instance-path$)
  375.                                               sm:*default-instance-file-path*)))
  376.                            (make-pathname
  377.                             :device    (pathname-device prev-path)
  378.                             :directory (pathname-directory prev-path)
  379.                             :name      (symbol-name dnet)
  380.                             :type      sm:*default-instance-file-type*)))))
  381.                       (backup-path
  382.                        (make-pathname
  383.                         :host      (pathname-host file-path)
  384.                         :device    (pathname-device file-path)
  385.                         :directory (pathname-directory file-path)
  386.                         :name      (pathname-name file-path)
  387.                         :type      "bak")))
  388.                  (if (probe-file file-path)
  389.                    (progn
  390.                      (if (probe-file backup-path)
  391.                        (delete-file backup-path))
  392.                      (rename-file file-path backup-path)
  393.                      (format T "~&;~A backed up to ~A" 
  394.                              (namestring file-path)
  395.                              (namestring backup-path))))
  396.                  (setf *default-instance-file-path*
  397.                        (directory-namestring file-path))
  398.                  (ccl:eval-enqueue
  399.                   `(progn
  400.                      (save-dnet ',dnet ',file-path :user)
  401.                      (format T "~&;DNET ~A saved to ~S"
  402.                              ',dnet
  403.                              ',(namestring file-path))))))))
  404.          (hide-item
  405.           (ccl:oneof ccl:*menu-item*
  406.                      :menu-item-title "Hide This Menu"
  407.                      :menu-item-action 
  408.                      '(ccl:ask *dnet-menu* (ccl:menu-deinstall))))
  409.          (dnet-menu (ccl:oneof ccl:*menu* 
  410.                                :menu-title "DNET"
  411.                                :menu-items (list browse-item
  412.                                                  line-item
  413.                                                  destroy-dnet-item
  414.                                                  save-dnet-item
  415.                                                  line-item
  416.                                                  hide-item))))
  417.     (ccl:ask dnet-menu (ccl:menu-install))
  418.     (ccl:ask line-item (ccl:menu-item-disable))
  419.     ;; Menu-dispose dumped from version 1.3.1?
  420.     (if (and (boundp '*dnet-menu*)
  421.              (typep *dnet-menu* ccl:*menu*))
  422.         (ccl:ask *dnet-menu* (ccl:menu-deinstall)))
  423.     dnet-menu))
  424.  
  425. (ccl:ask ccl:*tools-menu*
  426.   (ccl:add-menu-items
  427.    (ccl:oneof ccl:*menu-item*
  428.           :menu-item-title "Restore DNET Menu"
  429.           :menu-item-action
  430.           #'(lambda ()
  431.               (ccl:ask *dnet-menu*
  432.                 (unless (ccl:menu-installed-p) (ccl:menu-install)))))))
  433.  
  434. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  435. (provide :DNET-BROWSER)
  436. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  437. ;;; EOF
  438.